Usenet 1993 July

home *** CD-ROM | disk | FTP | other *** search

/ Usenet 1993 July / InfoMagic USENET CD-ROM July 1993.ISO / sources / unix / volume10 / ptoc / part10 < prev next >

Wrap

Internet Message Format | 1987-07-28 | 55.7 KB

Path: uunet!rs From: rs@uunet.UU.NET (Rich Salz) Newsgroups: comp.sources.unix Subject: v10i074: Pascal to C translator, Part10/12 Message-ID: <727@uunet.UU.NET> Date: 30 Jul 87 00:30:53 GMT Organization: UUNET Communications Services, Arlington, VA Lines: 2548 Approved: rs@uunet.UU.NET Submitted-by: Per Bergsten <mcvax!enea!chalmers!holtec!perb> Posting-number: Volume 10, Issue 74 Archive-name: ptoc/Part10 #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 10 (of 12)." # Contents: ptc.p.2 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'ptc.p.2' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'ptc.p.2'\" else echo shar: Extracting \"'ptc.p.2'\" $52771 characters$ sed "s/^X//" >'ptc.p.2' <<'END_OF_FILE' X if sp^.lt = lforwlab then X sp^.lt := llabel X else X error(emuldeflab); X end; X oldlbl := tp X end; X X (* Parse declaration and statement-body for prog/subs. *) X procedure pbody(tp : treeptr); X X var tq : treeptr; X X begin X statlvl := statlvl + 1; X if currsym.st = slabel then X begin X tp^.tsublab := plabel; X linkup(tp, tp^.tsublab) X end X else X tp^.tsublab := nil; X if currsym.st = sconst then X begin X tp^.tsubconst := pconst; X linkup(tp, tp^.tsubconst) X end X else X tp^.tsubconst := nil; X if currsym.st = stype then X begin X tp^.tsubtype := ptype; X linkup(tp, tp^.tsubtype) X end X else X tp^.tsubtype := nil; X if currsym.st = svar then X begin X tp^.tsubvar := pvar; X linkup(tp, tp^.tsubvar) X end X else X tp^.tsubvar := nil; X tp^.tsubsub := nil; X tq := nil; X while (currsym.st = sproc) or (currsym.st = sfunc) do X begin X if tq = nil then X begin X tq := psubs; X tp^.tsubsub := tq X end X else begin X tq^.tnext := psubs; X tq := tq^.tnext X end X end; X linkup(tp, tp^.tsubsub); X checksymbol([sbegin, seof]); X if currsym.st = sbegin then X begin X tp^.tsubstmt := pbegin(false); X linkup(tp, tp^.tsubstmt) X end; X statlvl := statlvl - 1 X end; X X (* Parse program-declaration. *) X function pprogram : treeptr; X X var tp : treeptr; X X (* Parse a program parameter id-list. *) X function pprmlist : treeptr; X X label 999; X X var tp, X tq : treeptr; X din, X dut : idptr; X X begin X tp := nil; X din := deftab[dinput]^.tidl^.tsym^.lid; X dut := deftab[doutput]^.tidl^.tsym^.lid; X while (currsym.vid = din) or (currsym.vid = dut) do X begin X (* ignore input/output as parameters so that X they will be bound to stdin/stdout unless X declared as variables *) X if currsym.vid = din then X defnams[dinput]^.lused := true X else X defnams[doutput]^.lused := true; X nextsymbol([scomma, srpar]); X if currsym.st = srpar then X goto 999; X nextsymbol([sid]) X end; X tq := newid(currsym.vid); X tq^.tsym^.lt := lpointer; X tp := tq; X nextsymbol([scomma, srpar]); X while currsym.st = scomma do X begin X nextsymbol([sid]); X if currsym.vid = din then X defnams[dinput]^.lused := true X else if currsym.vid = dut then X defnams[doutput]^.lused := true X else begin X tq^.tnext := newid(currsym.vid); X tq := tq^.tnext; X tq^.tsym^.lt := lpointer; X end; X nextsymbol([scomma, srpar]) X end; X 999: X pprmlist := tp X end; X X begin (* pprogram *) X enterscope(nil); X tp := mknode(npgm); X nextsymbol([sid]); X tp^.tstat := statlvl; X tp^.tsubid := mknode(nid); X tp^.tsubid^.tup := tp; X tp^.tsubid^.tsym := mksym(lidentifier); X tp^.tsubid^.tsym^.lid := currsym.vid; X tp^.tsubid^.tsym^.lsymdecl := tp^.tsubid; X linkup(tp, tp^.tsubid); X nextsymbol([slpar, ssemic]); X if currsym.st = slpar then X begin X nextsymbol([sid]); X tp^.tsubpar := pprmlist; X linkup(tp, tp^.tsubpar); X nextsymbol([ssemic]) X end X else X tp^.tsubpar := nil; X nextsymbol([slabel, sconst, stype, svar, X sproc, sfunc, sbegin]); X pbody(tp); X checksymbol([sdot]); X tp^.tscope := currscope; X leavescope; X pprogram := tp X end; (* pprogram *) X X (* Parse a module. *) X function pmodule : treeptr; X X var tp : treeptr; X X begin (* pmodule *) X enterscope(nil); X tp := mknode(npgm); X tp^.tstat := statlvl; X tp^.tsubid := nil; X tp^.tsubpar := nil; X pbody(tp); X checksymbol([ssemic]); X tp^.tscope := currscope; X leavescope; X pmodule := tp X end; (* pmodule *) X X X (* Parse label-clause. *) X function plabel; X X var tp, X tq : treeptr; X X begin X tq := nil; X repeat X nextsymbol([sinteger]); X if tq = nil then X begin X tq := newlbl; X tp := tq X end X else begin X tq^.tnext := newlbl; X tq := tq^.tnext; X end; X nextsymbol([scomma, ssemic]) X until currsym.st = ssemic; X nextsymbol([sconst, stype, svar, sbegin, sproc, sfunc]); X plabel := tp X end; X X (* Parse an id-list. *) X function pidlist; X X var tp, X tq : treeptr; X X begin X tq := newid(currsym.vid); X tq^.tsym^.lt := l; X tp := tq; X nextsymbol([scomma, scolon, seq, srpar]); X while currsym.st = scomma do X begin X nextsymbol([sid]); X tq^.tnext := newid(currsym.vid); X tq := tq^.tnext; X tq^.tsym^.lt := l; X nextsymbol([scomma, scolon, seq, srpar]) X end; X pidlist := tp X end; X X (* Parse const-clause. *) X function pconst; X X var tp, X tq : treeptr; X X begin X tq := nil; X nextsymbol([sid]); X repeat X if tq = nil then X begin X tq := mknode(nconst); X tq^.tattr := anone; X tp := tq X end X else begin X tq^.tnext := mknode(nconst); X tq := tq^.tnext; X tq^.tattr := anone X end; X tq^.tidl := pidlist(lidentifier); X checksymbol([seq]); X nextsymbol([sid, schar, sstring, sinteger, sreal, X splus, sminus]); X tq^.tbind := pconstant(true); X nextsymbol([ssemic]); X nextsymbol([sid, stype, svar, sbegin, X sfunc, sproc, seof]) X until currsym.st <> sid; X pconst := tp X end; X X (* Parse a declared constant or a case-statment const. *) X function pconstant; X X var tp, X tq : treeptr; X neg : boolean; X X begin X neg := currsym.st = sminus; X if currsym.st in [splus, sminus] then X if realok then X nextsymbol([sid, sinteger, sreal]) X else X nextsymbol([sid, sinteger]); X if currsym.st = sid then X tp := oldid(currsym.vid, lidentifier) X else X tp := mklit; X if neg then X begin X tq := mknode(numinus); X tq^.texps := tp; X tp := tq X end; X pconstant := tp X end; X X (* Parse a record (or record-variant) declaration. *) X (* Cs is the expected closing symbol, dp the scope. *) X function precord; X X label 999; X X var tp, X tq, X tl, X tv : treeptr; X tsym : lexsym; X X begin X tp := mknode(nrecord); X tp^.tflist := nil; X tp^.tvlist := nil; X tp^.tuid := nil; X tp^.trscope := nil; X if cs = send then X begin X enterscope(dp); X dp := currscope X end; X nextsymbol([sid, scase] + [cs]); X tq := nil; X while currsym.st = sid do X begin X if tq = nil then X begin X tq := mknode(nfield); X tq^.tattr := anone; X tp^.tflist := tq X end X else begin X tq^.tnext := mknode(nfield); X tq := tq^.tnext; X tq^.tattr := anone X end; X tq^.tidl := pidlist(lfield); X checksymbol([scolon]); X leavescope; X tq^.tbind := ptypedef; X enterscope(dp); X if currsym.st = ssemic then X nextsymbol([sid, scase] + [cs]) X end; X if currsym.st = scase then X begin X nextsymbol([sid]); X tsym := currsym; X nextsymbol([scolon, sof]); X if currsym.st = scolon then X begin X tv := newid(tsym.vid); X if tq = nil then X begin X tq := mknode(nfield); X tp^.tflist := tq X end X else begin X tq^.tnext := mknode(nfield); X tq := tq^.tnext X end; X tq^.tidl := tv; X tv^.tsym^.lt := lfield; X nextsymbol([sid]); X leavescope; X tq^.tbind := oldid(currsym.vid, lidentifier); X enterscope(dp); X nextsymbol([sof]) X end; X tq := nil; X repeat X tv := nil; X repeat X nextsymbol([sid, sinteger, schar, splus, X sminus] + [cs]); X if currsym.st = cs then X goto 999; X if tv = nil then X begin X tv := pconstant(false); X tl := tv X end X else begin X tv^.tnext := pconstant(false); X tv := tv^.tnext X end; X nextsymbol([scolon, scomma]) X until currsym.st = scolon; X nextsymbol([slpar]); X if tq = nil then X begin X tq := mknode(nvariant); X tp^.tvlist := tq; X end X else begin X tq^.tnext := mknode(nvariant); X tq := tq^.tnext; X end; X tq^.tselct := tl; X tq^.tvrnt := precord(srpar, dp) X until currsym.st = cs X end; X 999: X if cs = send then X begin X tp^.trscope := dp; X leavescope X end; X nextsymbol([ssemic, send, srpar]); X (* currsym is the symbol following record end/rpar, X (usually semicolon, sometimes enclosing end/rpar) *) X precord := tp X end; X X function ptypedef; X X var tp, X tq : treeptr; X st : symtyp; X ss : symset; X X begin X nextsymbol([sid, slpar, sarrow, sinteger, schar, splus, sminus, X spacked, sarray, srecord, sfile, sset]); X X (* the "packed" keyword is completely ignored *) X if currsym.st = spacked then X nextsymbol([sarray, srecord, sfile, sset]); X X ss := [ssemic, send, srpar, scomma, srbrack]; X case currsym.st of X splus, X sminus, X schar, X sinteger, X sid: X begin X st := currsym.st; X tp := pconstant(false); X if st = sid then X nextsymbol([sdotdot] + ss) X else X nextsymbol([sdotdot]); X if currsym.st = sdotdot then X begin X nextsymbol([sid, sinteger, schar, X splus, sminus]); X tq := mknode(nsubrange); X tq^.tlo := tp; X tq^.thi := pconstant(false); X tp := tq; X nextsymbol(ss) X end X end; X slpar: X begin X tp := mknode(nscalar); X nextsymbol([sid]); X tp^.tscalid := pidlist(lidentifier); X checksymbol([srpar]); X nextsymbol(ss) X end; X sarrow: X begin X tp := mknode(nptr); X nextsymbol([sid]); X tp^.tptrid := oldid(currsym.vid, lpointer); X tp^.tptrflag := false; X nextsymbol([ssemic, send, srpar]) X end; X sarray: X begin X nextsymbol([slbrack]); X tp := mknode(narray); X tp^.taindx := ptypedef; (* parse subrange ... *) X tq := tp; X while currsym.st = scomma do X begin X (* expand: array [ A , B ] of X X to: array [ A ] of array [ B ] of X *) X tq^.taelem := mknode(narray); X tq := tq^.taelem; X tq^.taindx := ptypedef (* ... again *) X end; X checksymbol([srbrack]); X nextsymbol([sof]); X tq^.taelem := ptypedef X end; X srecord: X tp := precord(send, nil); X sfile, X sset: X begin X if currsym.st = sfile then X tp := mknode(nfileof) X else begin X tp := mknode(nsetof); X usesets := true X end; X nextsymbol([sof]); X tp^.tof := ptypedef X end X end; X (* at this point "currsym" holds the symbol following the type X (usually semicolon, sometimes the following end/rpar) *) X ptypedef := tp X end; X X (* Parse type-clause. *) X function ptype; X X var tp, X tq : treeptr; X X begin X tq := nil; X nextsymbol([sid]); X repeat X if tq = nil then X begin X tq := mknode(ntype); X tq^.tattr := anone; X tp := tq X end X else begin X tq^.tnext := mknode(ntype); X tq := tq^.tnext; X tq^.tattr := anone X end; X tq^.tidl := pidlist(lidentifier); X checksymbol([seq]); X tq^.tbind := ptypedef; X nextsymbol([sid, svar, sbegin, sfunc, sproc, seof]) X until currsym.st <> sid; X ptype := tp; X end; X X (* Parse var-clause. *) X function pvar; X X var ti, X tp, X tq : treeptr; X X begin X tq := nil; X nextsymbol([sid]); X repeat X if tq = nil then X begin X tq := mknode(nvar); X tq^.tattr := anone; X tp := tq X end X else begin X tq^.tnext := mknode(nvar); X tq := tq^.tnext; X tq^.tattr := anone X end; X X ti := newid(currsym.vid); X tq^.tidl := ti; X nextsymbol([scomma, scolon]); X while currsym.st = scomma do X begin X nextsymbol([sid]); X ti^.tnext := newid(currsym.vid); X ti := ti^.tnext; X nextsymbol([scomma, scolon]) X end; X X tq^.tbind := ptypedef; X nextsymbol([sid, sbegin, sfunc, sproc, seof]) X until currsym.st <> sid; X pvar := tp X end; X X (* Parse subroutine-declaration. *) X function psubs; X X var tp, (* return value *) X tv, tq : treeptr; (* temporary *) X func : boolean; (* true for functions *) X colsem : symtyp; (* colon/semicolon *) X X begin X (* parsing function or procedure *) X func := currsym.st = sfunc; X if func then X colsem := scolon X else X colsem := ssemic; X X (* parse id, it may already be forward declared *) X nextsymbol([sid]); X tq := newid(currsym.vid); X if tq^.tup = nil then X begin X enterscope(nil); X (* id wasn't previously declared, params possible *) X if func then X tp := mknode(nfunc) X else X tp := mknode(nproc); X tp^.tstat := statlvl; X tp^.tsubid := tq; X linkup(tp, tq); X nextsymbol([slpar, colsem]); X if currsym.st = slpar then X begin X tp^.tsubpar := psubpar; X linkup(tp, tp^.tsubpar); X nextsymbol([colsem]) X end X else X tp^.tsubpar := nil; X if func then X begin X (* parse function type *) X nextsymbol([sid]); X tp^.tfuntyp := oldid(currsym.vid, lidentifier); X nextsymbol([ssemic]) X end X else X tp^.tfuntyp := mknode(nempty); X linkup(tp, tp^.tfuntyp); X nextsymbol([sextern, sforward, X slabel, sconst, stype, svar, X sproc, sfunc, sbegin]); X end X else begin X (* id was forward declared => X pick up declarations from parameterlist *) X enterscope(tq^.tup^.tscope); X if func then X tp := mknode(nfunc) X else X tp := mknode(nproc); X tp^.tfuntyp := tq^.tup^.tfuntyp; X (* steal id and params from forward decl *) X tv := tq^.tup^.tsubpar; X tp^.tsubpar := tv; X while tv <> nil do X begin X tv^.tup := tp; X tv := tv^.tnext X end; X tp^.tsubid := tq; X tq^.tup := tp; X (* id was forward declared => X no params, no function type, no forward *) X nextsymbol([ssemic]); X nextsymbol([slabel, sconst, stype, svar, X sproc, sfunc, sbegin]); X end; X if currsym.st in [sforward, sextern] then X begin X tp^.tsubid^.tsym^.lt := lforward; X nextsymbol([ssemic]); X tp^.tsublab := nil; X tp^.tsubconst := nil; X tp^.tsubtype := nil; X tp^.tsubvar := nil; X tp^.tsubsub := nil; X tp^.tsubstmt := nil X end X else X pbody(tp); X nextsymbol([sproc, sfunc, sbegin, seof]); X tp^.tscope := currscope; X leavescope; X psubs := tp X end; X X (* Parse a conformant array index type. *) X function pconfsub : treeptr; X X var tp : treeptr; X X begin X tp := mknode(nsubrange); X nextsymbol([sid]); X tp^.tlo := newid(currsym.vid); X nextsymbol([sdotdot]); X nextsymbol([sid]); X tp^.thi := newid(currsym.vid); X nextsymbol([scolon]); X pconfsub := tp X end; X X (* Parse a conformant array-declaration. *) X function pconform : treeptr; X X var tp, tq : treeptr; X X begin X nextsymbol([slbrack]); X tp := mknode(nconfarr); X tp^.tcuid := mkvariable('S'); X tp^.tcindx := pconfsub; (* parse subrange ... *) X nextsymbol([sid]); X tp^.tindtyp := oldid(currsym.vid, lidentifier); X nextsymbol([ssemic, srbrack]); X tq := tp; X while currsym.st = ssemic do X begin X error(econfconf); (* what size does tp have *) X X (* expand: array [ A ; B ] of X X to: array [ A ] of array [ B ] of X *) X tq^.tcelem := mknode(nconfarr); X tq := tq^.tcelem; X tq^.tcindx := pconfsub; (* ... again *) X nextsymbol([sid]); X tq^.tindtyp := oldid(currsym.vid, lidentifier); X nextsymbol([ssemic, srbrack]) X end; X nextsymbol([sof]); X nextsymbol([sid, sarray]); X case currsym.st of X sid: X tq^.tcelem := oldid(currsym.vid, lidentifier); X sarray: X begin X error(econfconf); (* what size does tp have *) X X tq^.tcelem := pconform X end; X end;(* case *) X pconform := tp X end; X X (* Parse subroutine parameter list. *) X function psubpar; X X var tp, X tq : treeptr; X nt : treetyp; X X begin X tq := nil; X repeat X nextsymbol([sid, svar, sfunc, sproc]); X case currsym.st of X sid: X nt := nvalpar; X svar: X nt := nvarpar; X sfunc: X nt := nparfunc; X sproc: X nt := nparproc; X end; X if nt <> nvalpar then X nextsymbol([sid]); X if tq = nil then X begin X tq := mknode(nt); X tp := tq X end X else begin X tq^.tnext := mknode(nt); X tq := tq^.tnext X end; X case nt of X nvarpar, X nvalpar: X begin X tq^.tidl := pidlist(lidentifier); X tq^.tattr := anone; X checksymbol([scolon]); X if nt = nvalpar then X nextsymbol([sid]) X else X nextsymbol([sid, sarray]); X case currsym.st of X sid: X tq^.tbind := X oldid(currsym.vid, lidentifier); X sarray: X tq^.tbind := pconform X end;(* case *) X nextsymbol([srpar, ssemic]) X end; X nparproc: X begin X tq^.tparid := newid(currsym.vid); X nextsymbol([ssemic, slpar, srpar]); X if currsym.st = slpar then X begin X enterscope(nil); X tq^.tparparm := psubpar; X nextsymbol([ssemic, srpar]); X leavescope X end X else X tq^.tparparm := nil; X tq^.tpartyp := nil X end; X nparfunc: X begin X tq^.tparid := newid(currsym.vid); X nextsymbol([scolon, slpar]); X if currsym.st = slpar then X begin X enterscope(nil); X tq^.tparparm := psubpar; X nextsymbol([scolon]); X leavescope X end X else X tq^.tparparm := nil; X nextsymbol([sid]); X tq^.tpartyp := oldid(currsym.vid, lidentifier); X nextsymbol([srpar, ssemic]) X end X end (* case *) X until currsym.st = srpar; X psubpar := tp X end; X X (* Parse a (possibly labeled) statement. *) X function plabstmt; X X var tp : treeptr; X X begin X nextsymbol([sid, sinteger, sif, swhile, srepeat, sfor, scase, X swith, sbegin, sgoto, X selse, ssemic, send, suntil]); X if currsym.st = sinteger then X begin X tp := mknode(nlabstmt); X tp^.tlabno := oldlbl(true); X nextsymbol([scolon]); X nextsymbol([sid, sif, swhile, srepeat, sfor, scase, X swith, sbegin, sgoto, X selse, ssemic, send, suntil]); X tp^.tstmt := pstmt X end X else X tp := pstmt; X plabstmt := tp X end; X X (* Parse an unlabeled statement. *) X function pstmt; X X var tp : treeptr; X X begin X case currsym.st of X sid: X tp := psimple; X sif: X tp := pif; X swhile: X tp := pwhile; X srepeat: X tp := prepeat; X sfor: X tp := pfor; X scase: X tp := pcase; X swith: X tp := pwith; X sbegin: X tp := pbegin(true); X sgoto: X tp := pgoto; X send, X selse, X suntil, X ssemic: X tp := mknode(nempty); X end; X pstmt := tp X end; X X (* Parse an assignment or a procedure call. *) X function psimple; X X var tq, X tp : treeptr; X X begin X tp := pvariable(oldid(currsym.vid, lidentifier)); X if currsym.st = sassign then X begin X tq := mknode(nassign); X tq^.tlhs := tp; X tq^.trhs := pexpr(nil); X tp := tq X end; X psimple := tp X end; X X (* Parse a varable-reference (or a subroutine-call). *) X function pvariable; X X var tp, X tq : treeptr; X X begin X nextsymbol([slpar, slbrack, sdot, sarrow, X sassign, ssemic, scomma, scolon, sdotdot, X splus, sminus, smul, sdiv, smod, squot, X sand, sor, sinn, srpar, srbrack, X sle, slt, seq, sge, sgt, sne, X send, suntil, sthen, selse, sdo, sdownto, sto, sof]); X if currsym.st in [slpar, slbrack, sdot, sarrow] then X begin X case currsym.st of X slpar: X begin X tp := mknode(ncall); X tp^.tcall := varptr; X tq := nil; X repeat X if tq = nil then X begin X tq := pexpr(nil); X tp^.taparm := tq X end X else begin X tq^.tnext := pexpr(nil); X tq := tq^.tnext X end; X until currsym.st = srpar X end; X slbrack: X begin X tq := varptr; X repeat X tp := mknode(nindex); X tp^.tvariable := tq; X tp^.toffset := pexpr(nil); X tq := tp X until currsym.st = srbrack X end; X sdot: X begin X tp := mknode(nselect); X tp^.trecord := varptr; X nextsymbol([sid]); X tq := typeof(varptr); X enterscope(tq^.trscope); X tp^.tfield := oldid(currsym.vid, lfield); X leavescope X end; X sarrow: X begin X tp := mknode(nderef); X tp^.texps := varptr X end X end;(* case *) X tp := pvariable(tp) X end X else begin X tp := varptr; X if tp^.tt = nid then X begin X tq := idup(tp); X if tq <> nil then X if tq^.tt in [nfunc, nproc, X nparproc, nparfunc] then X begin X (* subroutine-call without X parameters *) X tp := mknode(ncall); X tp^.tcall := varptr; X tp^.taparm := nil X end X end X end; X pvariable := tp X end; X X (* Parse an expression. *) X function pexpr; X X var tp, X tq : treeptr; X nt : treetyp; X next : boolean; X X function padjust(tu, tr : treeptr) : treeptr; X begin X if pprio[tu^.tt] >= pprio[tr^.tt] then X begin X if tr^.tt in [nnot, numinus, nuplus, X nset, nderef] then X tr^.texps := padjust(tu, tr^.texps) X else X tr^.texpl := padjust(tu, tr^.texpl); X padjust := tr X end X else begin X if tu^.tt in [nnot, numinus, nuplus, X nset, nderef] then X tu^.texps := tr X else X tu^.texpr := tr; X padjust := tu X end X end; X X begin X nextsymbol([sid, schar, sinteger, sreal, sstring, snil, X splus, sminus, snot, slpar, slbrack, srbrack]); X next := true; X case currsym.st of X splus: X begin X tp := mknode(nuplus); X tp^.texps := nil; X tp := pexpr(tp); X next := false X end; X sminus: X begin X tp := mknode(numinus); X tp^.texps := nil; X tp := pexpr(tp); X next := false X end; X snot: X begin X tp := mknode(nnot); X tp^.texps := nil; X tp := pexpr(tp); X next := false X end; X schar, X sinteger, X sreal, X sstring: X tp := mklit; X snil: X begin X usenilp := true; X tp := mknode(nnil); X end; X sid: X begin X tp := pvariable(oldid(currsym.vid, lidentifier)); X next := false X end; X slpar: X begin X tp := mknode(nuplus); X tp^.texps := pexpr(nil) X end; X slbrack: X begin X usesets := true; X tp := mknode(nset); X tp^.texps := nil; X tq := nil; X repeat X if tq = nil then X begin X tq := pexpr(nil); X tp^.texps := tq X end X else begin X tq^.tnext := pexpr(nil); X tq := tq^.tnext X end X until currsym.st = srbrack; X end; X srbrack: X begin X tp := mknode(nempty); X next := false X end X end; X if next then X nextsymbol([ X scolon, ssemic, scomma, sdotdot, srpar, srbrack, X sle, slt, seq, sge, sgt, sne, X splus, sminus, smul, sdiv, smod, squot, X sand, sor, sinn, X send, suntil, sthen, selse, sdo, sdownto, sto, X sof, slpar, slbrack]); X case currsym.st of X sdotdot: X nt := nrange; X splus: X nt := nplus; X sminus: X nt := nminus; X smul: X nt := nmul; X sdiv: X nt := ndiv; X smod: X nt := nmod; X squot: X begin X defnams[dreal]^.lused := true; X nt := nquot; X end; X sand: X nt := nand; X sor: X nt := nor; X sinn: X begin X nt := nin; X usesets := true X end; X sle: X nt := nle; X slt: X nt := nlt; X seq: X nt := neq; X sge: X nt := nge; X sgt: X nt := ngt; X sne: X nt := nne; X scolon: X nt := nformat; X sid, schar, sinteger, sreal, sstring, snil, X ssemic, scomma, slpar, slbrack, srpar, srbrack, X send, suntil, sthen, selse, sdo, sdownto, sto, sof: X nt := nnil X end;(* case *) X if nt in [nin .. nor, nand, nnot] then X defnams[dboolean]^.lused := true; X if nt <> nnil then X begin X (* binary operator *) X tq := mknode(nt); X tq^.texpl := tp; X tq^.texpr := nil; X tp := pexpr(tq) X end; X X (* this statement yilds proper operator precedence *) X if tnp <> nil then X tp := padjust(tnp, tp); X pexpr := tp X end; X X (* Parse a case-statement. *) X function pcase; X X label 999; X X var tp, X tq, X tv : treeptr; X X begin X tp := mknode(ncase); X tp^.tcasxp := pexpr(nil); X checksymbol([sof]); X tq := nil; X repeat X if tq = nil then X begin X tq := mknode(nchoise); X tp^.tcaslst := tq X end X else begin X tq^.tnext := mknode(nchoise); X tq := tq^.tnext X end; X tv := nil; X repeat X nextsymbol([sid, sinteger, schar, X splus, sminus, send, sother]); X if currsym.st in [send, sother] then X goto 999; X if tv = nil then X begin X tv := pconstant(false); X tq^.tchocon := tv X end X else begin X tv^.tnext := pconstant(false); X tv := tv^.tnext X end; X nextsymbol([scomma, scolon]) X until currsym.st = scolon; X tq^.tchostmt := plabstmt X until currsym.st = send; X 999: X if currsym.st = sother then X begin X nextsymbol([scolon, sid, sif, swhile, srepeat, sfor, X scase, swith, sbegin, sgoto, X selse, ssemic, send, suntil]); X if currsym.st = scolon then X nextsymbol([sid, sif, swhile, srepeat, sfor, X scase, swith, sbegin, sgoto, X selse, ssemic, send, suntil]); X tp^.tcasother := pstmt X end X else begin X tp^.tcasother := nil; X usecase := true X end; X nextsymbol([ssemic, send, selse, suntil]); X pcase := tp X end; X X (* Parse an if-statement. *) X function pif; X X var tp : treeptr; X X begin X tp := mknode(nif); X tp^.tifxp := pexpr(nil); X checksymbol([sthen]); X tp^.tthen := plabstmt; X if currsym.st = selse then X tp^.telse := plabstmt X else X tp^.telse := nil; X pif := tp; X end; X X (* Parse a while-statement. *) X function pwhile; X X var tp : treeptr; X X begin X tp := mknode(nwhile); X tp^.twhixp := pexpr(nil); X checksymbol([sdo]); X tp^.twhistmt := plabstmt; X pwhile := tp; X end; X X (* Parse a repeat-statement. *) X function prepeat; X X var tp, X tq : treeptr; X X begin X tp := mknode(nrepeat); X tq := nil; X repeat X if tq = nil then X begin X tq := plabstmt; X tp^.treptstmt := tq X end X else begin X tq^.tnext := plabstmt; X tq := tq^.tnext X end; X checksymbol([ssemic, suntil]) X until currsym.st = suntil; X tp^.treptxp := pexpr(nil); X prepeat := tp X end; X X (* Parse a for-statement. *) X function pfor; X X var tp : treeptr; X X begin X tp := mknode(nfor); X nextsymbol([sid]); X tp^.tforid := oldid(currsym.vid, lidentifier); X nextsymbol([sassign]); X tp^.tfrom := pexpr(nil); X checksymbol([sdownto, sto]); X tp^.tincr := currsym.st = sto; X tp^.tto := pexpr(nil); X checksymbol([sdo]); X tp^.tforstmt := plabstmt; X pfor := tp X end; X X (* Parse a with-statement. *) X function pwith; X X var tp, X tq : treeptr; X X begin X tp := mknode(nwith); X tq := nil; X repeat X if tq = nil then X begin X tq := mknode(nwithvar); X tp^.twithvar := tq X end X else begin X tq^.tnext := mknode(nwithvar); X tq := tq^.tnext X end; X enterscope(nil); X tq^.tenv := currscope; X tq^.texpw := pexpr(nil); X scopeup(tq^.texpw); X checksymbol([scomma, sdo]) X until currsym.st = sdo; X tp^.twithstmt := plabstmt; X tq := tp^.twithvar; X while tq <> nil do X begin X leavescope; X tq := tq^.tnext X end; X pwith := tp X end; X X (* Parse a goto-statement. *) X function pgoto; X X var tp : treeptr; X X begin X nextsymbol([sinteger]); X tp := mknode(ngoto); X tp^.tlabel := oldlbl(false); X nextsymbol([ssemic, send, suntil, selse]); X pgoto := tp X end; X X (* Parse a begin-statement. *) X function pbegin; X X var tp, X tq : treeptr; X X begin X tq := nil; X repeat X if tq = nil then X begin X tq := plabstmt; X tp := tq X end X else begin X tq^.tnext := plabstmt; X tq := tq^.tnext X end X until currsym.st = send; X if retain then X begin X tq := mknode(nbegin); X tq^.tbegin := tp; X tp := tq X end; X nextsymbol([send, selse, suntil, sdot, ssemic]); X pbegin := tp X end; X Xbegin (* parse *) X nextsymbol([spgm, sconst, stype, svar, sproc, sfunc]); X if currsym.st = spgm then X top := pprogram X else X top := pmodule; X nextsymbol([seof]); Xend; (* parse *) X X(* Compute value for a node (which must be some kind of constant). *) Xfunction cvalof(tp : treeptr) : integer; X Xvar v : integer; X tq : treeptr; X Xbegin X case tp^.tt of X nuplus: X cvalof := cvalof(tp^.texps); X numinus: X cvalof := - cvalof(tp^.texps); X nnot: X cvalof := 1 - cvalof(tp^.texps); X nid: X begin X tq := idup(tp); X if tq = nil then X fatal(etree); X tp := tp^.tsym^.lsymdecl; X case tq^.tt of X nscalar: X begin X v := 0; X tq := tq^.tscalid; X while tq <> nil do X if tq = tp then X tq := nil X else begin X v := v + 1; X tq := tq^.tnext X end; X cvalof := v X end; X nconst: X cvalof := cvalof(tq^.tbind); X end;(* case *) X end; X ninteger: X cvalof := tp^.tsym^.linum; X nchar: X cvalof := ord(tp^.tsym^.lchar); X end (* case *) Xend; (* cvalof *) X X(* Compute lower value of subrange or scalar type. *) Xfunction clower(tp : treeptr) : integer; X Xvar tq : treeptr; X Xbegin X tq := typeof(tp); X if tq^.tt = nscalar then X clower := scalbase X else if tq^.tt = nsubrange then X if tq^.tup^.tt = nconfarr then X clower := 0 X else X clower := cvalof(tq^.tlo) X else if tq = typnods[tchar] then X clower := 0 X else if tq = typnods[tinteger] then X clower := -maxint X else X fatal(etree) Xend; (* clower *) X X(* Compute upper value of subrange or scalar type. *) Xfunction cupper(tp : treeptr) : integer; X Xvar tq : treeptr; X i : integer; X Xbegin X tq := typeof(tp); X if tq^.tt = nscalar then X begin X tq := tq^.tscalid; X i := scalbase; X while tq^.tnext <> nil do X begin X i := i + 1; X tq := tq^.tnext X end; X cupper := i X end X else if tq^.tt = nsubrange then X if tq^.tup^.tt = nconfarr then X fatal(euprconf) X else X cupper := cvalof(tq^.thi) X else if tq = typnods[tchar] then X cupper := maxchar X else if tq = typnods[tinteger] then X cupper := maxint X else X fatal(etree) Xend; (* cupper *) X X(* Compute the number of elements in a subrange. *) Xfunction crange(tp : treeptr) : integer; X Xbegin X crange := cupper(tp) - clower(tp) + 1 Xend; X X(* Return number of words uset to store a set. *) Xfunction csetwords(i : integer) : integer; X Xbegin X i := (i+(setbits)) div (setbits+1); X if i > maxsetrange then X error(esetsize); X csetwords := i Xend; X X(* Return number of words uset to store a set. *) Xfunction csetsize(tp : treeptr) : integer; X Xvar tq : treeptr; X i : integer; X Xbegin X tq := typeof(tp^.tof); X i := clower(tq); X (* bits in sets are always numbered from 0, so we (arbitrarily) X decide that the base must be in the first 6 words to avoid X unnecessary waste of space *) X if (i < 0) or (i >= 6 * (setbits+1)) then X error(esetbase); X csetsize := csetwords(crange(tq)) + 1 Xend; X X(* Determine if tp is declared in the procedure it is used in. *) Xfunction islocal(tp : treeptr) : boolean; X Xvar tq : treeptr; X Xbegin X tq := tp^.tsym^.lsymdecl; X while not (tq^.tt in [nproc, nfunc, npgm]) do X tq := tq^.tup; X while not (tp^.tt in [nproc, nfunc, npgm]) do X tp := tp^.tup; X islocal := tp = tq Xend; X X(* Perform necessary transformations on tree and identifiers *) X(* before generating code. *) Xprocedure transform; X X X (* Rename function when used as a variable. *) X procedure renamf(tp : treeptr); X X var ip, iq : symptr; X tq, tv : treeptr; X X (* This procedure recursively descends the tree *) X (* and replaces function-assignments with variable *) X (* assignments. *) X procedure crtnvar(tp : treeptr); X X begin X while tp <> nil do X begin X case tp^.tt of X npgm: X crtnvar(tp^.tsubsub); X nfunc, X nproc: X begin X crtnvar(tp^.tsubsub); X crtnvar(tp^.tsubstmt) X end; X nbegin: X crtnvar(tp^.tbegin); X nif: X begin X crtnvar(tp^.tthen); X crtnvar(tp^.telse) X end; X nwhile: X crtnvar(tp^.twhistmt); X nrepeat: X crtnvar(tp^.treptstmt); X nfor: X crtnvar(tp^.tforstmt); X ncase: X begin X crtnvar(tp^.tcaslst); X crtnvar(tp^.tcasother) X end; X nchoise: X crtnvar(tp^.tchostmt); X nwith: X crtnvar(tp^.twithstmt); X nlabstmt: X crtnvar(tp^.tstmt); X nassign: X begin X (* revoke calls in assignment lhs, (mis- X parsed due to ambiguous syntax) *) X if tp^.tlhs^.tt = ncall then X begin X tp^.tlhs := tp^.tlhs^.tcall; X tp^.tlhs^.tup := tp X end; X (* function name -> variable name *) X tv := tp^.tlhs; X if tv^.tt = nid then X if tv^.tsym = ip then X tv^.tsym := iq X end; X nbreak, X npush, X npop, X ngoto, X nempty, X ncall: X (* no op *) X end;(* case *) X tp := tp^.tnext X end X end; X X begin (* renamf *) X while tp <> nil do X begin X case tp^.tt of X npgm, X nproc: X renamf(tp^.tsubsub); X nfunc: X begin X (* create a variable to hold return value *) X tq := mknode(nvar); X tq^.tattr := aregister; X tq^.tup := tp; X tq^.tidl := newid(mkvariable('R')); X tq^.tidl^.tup := tq; X tq^.tbind := tp^.tfuntyp; X (* put it FIRST among variables, see esubr() *) X tq^.tnext := tp^.tsubvar; X tp^.tsubvar := tq; X X iq := tq^.tidl^.tsym; X ip := tp^.tsubid^.tsym; X crtnvar(tp^.tsubsub); X crtnvar(tp^.tsubstmt); X (* process inner functions *) X renamf(tp^.tsubsub) X end; X end;(* case *) X tp := tp^.tnext X end X end; (* renamf *) X X (* This procedure rearranges the tree such that multiple *) X (* vardeclarations don't have (structured) types attached *) X (* to them. If such a declararation is found, a new name *) X (* is created and the type is moved to the type section. *) X procedure extract(tp : treeptr); X X var vp : treeptr; X X (* Create a declaration for tp, enter in pp type- *) X (* list and return an identifier referencing it. *) X function xtrit(tp, pp : treeptr; last : boolean) : treeptr; X X var np, rp : treeptr; X ip : idptr; X X begin X (* create new declaration *) X np := mknode(ntype); X ip := mkvariable('T'); X np^.tidl := newid(ip); X np^.tidl^.tup := np; X X (* create substitute id *) X rp := oldid(ip, lidentifier); X rp^.tup := tp^.tup; X rp^.tnext := tp^.tnext; X X (* steal type description *) X np^.tbind := tp; X tp^.tup := np; X tp^.tnext := nil; X X (* add new declaration to tree *) X np^.tup := pp; X if last and (pp^.tsubtype <> nil) then X begin X pp := pp^.tsubtype; X while pp^.tnext <> nil do X pp := pp^.tnext; X pp^.tnext := np X end X else begin X np^.tnext := pp^.tsubtype; X pp^.tsubtype := np; X end; X X xtrit := rp; X end; X X (* Extract anonymous enumeration types. *) X function xtrenum(tp, pp : treeptr) : treeptr; X X (* Name record-types referenced by ptrs. *) X procedure nametype(tp : treeptr); X X begin X tp := typeof(tp); X if tp^.tt = nrecord then X if tp^.tuid = nil then X tp^.tuid := mkvariable('S'); X end; X X begin X if tp <> nil then X begin X case tp^.tt of X nfield, X ntype, X nvar: X tp^.tbind := X xtrenum(tp^.tbind, pp); X X nscalar: X if tp^.tup^.tt <> ntype then X tp := xtrit(tp, pp, false); X X narray: X begin X tp^.taindx := xtrenum(tp^.taindx, pp); X tp^.taelem := xtrenum(tp^.taelem, pp); X end; X nrecord: X begin X tp^.tflist := xtrenum(tp^.tflist, pp); X tp^.tvlist := xtrenum(tp^.tvlist, pp); X end; X nvariant: X tp^.tvrnt := xtrenum(tp^.tvrnt, pp); X nfileof: X tp^.tof := xtrenum(tp^.tof, pp); X X nptr: X nametype(tp^.tptrid); X X nid, X nsubrange, X npredef, X nempty, X nsetof: X (* no op *) X end;(* case *) X tp^.tnext := xtrenum(tp^.tnext, pp) X end; X xtrenum := tp X end; X X begin (* extract *) X while tp <> nil do X begin X (* tp points to a program/procedure/function node *) X tp^.tsubtype := xtrenum(tp^.tsubtype, tp); X tp^.tsubvar := xtrenum(tp^.tsubvar, tp); X vp := tp^.tsubvar; X while vp <> nil do X begin X (* variables of structured unnamed types *) X if vp^.tbind^.tt in [nscalar, narray, X nrecord, nfileof] then X vp^.tbind := xtrit(vp^.tbind, tp, true); X vp := vp^.tnext X end; X extract(tp^.tsubsub); X tp := tp^.tnext X end X end; (* extract *) X X (* This procedure moves all local constants and types *) X (* used in nested procedures to the outermost declaration *) X (* level so that nested procedures may be extracted. *) X procedure global(tp, dp : treeptr; depend : boolean); X X label 555; X X var ip : treeptr; X dep : boolean; X X (* Mark all declared identifiers as unused. *) X procedure markdecl(xp : treeptr); X X begin X while xp <> nil do X begin X case xp^.tt of X nid: X xp^.tsym^.lused := false; X nconst: X markdecl(xp^.tidl); X ntype, X nvar, X nvalpar, X nvarpar, X nfield: X begin X markdecl(xp^.tidl); X if xp^.tbind^.tt <> nid then X markdecl(xp^.tbind) X end; X nscalar: X markdecl(xp^.tscalid); X nrecord: X begin X markdecl(xp^.tflist); X markdecl(xp^.tvlist) X end; X nvariant: X markdecl(xp^.tvrnt); X nconfarr: X if xp^.tcelem^.tt <> nid then X markdecl(xp^.tcelem); X narray: X if xp^.taelem^.tt <> nid then X markdecl(xp^.taelem); X nsetof, X nfileof: X if xp^.tof^.tt <> nid then X markdecl(xp^.tof); X nparproc, X nparfunc: X markdecl(xp^.tparid); X nptr, X nsubrange: X (* no op *) X end;(* case *) X xp := xp^.tnext X end X end; (* markdecl *) X X (* Move all marked declarations to global scope. *) X function movedecl(tp : treeptr) : treeptr; X X var ip, np : treeptr; X sp : symptr; X move : boolean; X X begin X if tp <> nil then X begin X move := false; X case tp^.tt of X nconst, X ntype: X ip := tp^.tidl X end;(* case *) X while ip <> nil do X begin X if ip^.tsym^.lused then X begin X move := true; X sp := ip^.tsym; X if sp^.lid^.inref > 1 then X begin X sp^.lid := X mkrename( 'M', sp^.lid); X sp^.lid^.inref := X sp^.lid^.inref - 1 X end; X ip := nil X end X else X ip := ip^.tnext X end; X if move then X begin X np := tp^.tnext; X tp^.tnext := nil; X ip := tp; X while ip^.tt <> npgm do X ip := ip^.tup; X tp^.tup := ip; X case tp^.tt of X nconst: X begin X if ip^.tsubconst = nil then X ip^.tsubconst := tp X else begin X ip := ip^.tsubconst; X while ip^.tnext <> nil X do ip := ip^.tnext; X ip^.tnext := tp X end X end; X ntype: X begin X if ip^.tsubtype = nil then X ip^.tsubtype := tp X else begin X ip := ip^.tsubtype; X while ip^.tnext <> nil X do ip := ip^.tnext; X ip^.tnext := tp X end X end X end;(* case *) X (* tp is moved, drop it and process X remainder of declarationlist *) X tp := movedecl(np) X end X else X tp^.tnext := movedecl(tp^.tnext) X end; X movedecl := tp X end; (* movedecl *) X X (* This procedure lifts out variables/parameters *) X (* used in nested procedures/functions. *) X procedure movevars(tp, vp : treeptr); X X label 555; X X var ep, dp, np : treeptr; X ip : idptr; X sp : symptr; X X (* Move a variable declaration to global *) X (* var declaration lists. *) X procedure moveglob(tp, dp : treeptr); X X begin X while tp^.tt <> npgm do X tp := tp^.tup; X dp^.tup := tp; X dp^.tnext := tp^.tsubvar; X tp^.tsubvar := dp X end; X X (* Create nodes for saving a global *) X (* pointer variable. *) X function stackop(decl, glob, loc : treeptr) : treeptr; X X var op, ip, dp, tp : treeptr; X X begin X (* create a new variable to hold old value X of the global variable during a call *) X ip := newid(mkvariable('F')); X case vp^.tt of X nvarpar, X nvalpar, X nvar: X begin X dp := mknode(nvarpar); X dp^.tattr := areference; X dp^.tidl := ip; X (* use same type as the global var *) X dp^.tbind := decl^.tbind X end; X nparproc, X nparfunc: X begin X dp := mknode(vp^.tt); X dp^.tparid := ip; X dp^.tparparm := nil; X dp^.tpartyp := vp^.tpartyp X end X end;(* case *) X ip^.tup := dp; X X (* add variable to declarationlists *) X tp := decl; X while not (tp^.tt in [nproc, nfunc, npgm]) do X tp := tp^.tup; X dp^.tup := tp; X if tp^.tsubvar = nil then X tp^.tsubvar := dp X else begin X tp := tp^.tsubvar; X while tp^.tnext <> nil do X tp := tp^.tnext; X tp^.tnext := dp X end; X dp^.tnext := nil; X X (* create an assignment saving value *) X op := mknode(npush); X op^.tglob := glob; X op^.tloc := loc; X op^.ttmp := ip; X stackop := op X end; X X (* Take a "push" node, create "pop" node *) X (* and add both to tree. *) X procedure addcode(tp, push : treeptr); X X var pop : treeptr; X X begin X pop := mknode(npop); X (* share variables with "push"-node *) X pop^.tglob := push^.tglob; X pop^.ttmp := push^.ttmp; X pop^.tloc := nil; X X (* add npush to head of statement list *) X push^.tnext := tp^.tsubstmt; X tp^.tsubstmt := push; X push^.tup := tp; X X (* add npop to end of statement list *) X while push^.tnext <> nil do X push := push^.tnext; X push^.tnext := pop; X pop^.tup := tp X end; X X begin (* movevars *) X while vp <> nil do X begin X case vp^.tt of X nvar, X nvalpar, X nvarpar: X dp := vp^.tidl; X nparproc, X nparfunc: X begin X dp := vp^.tparid; X if dp^.tsym^.lused then X begin X (* create a var declaration *) X ep := mknode(vp^.tt); X ep^.tparparm := nil; X ep^.tpartyp := vp^.tpartyp; X np := newid(mkrename('G', X dp^.tsym^.lid)); X ep^.tparid := np; X np^.tup := ep; X (* swap id's and symbols *) X sp := np^.tsym; X ip := sp^.lid; X np^.tsym^.lid := dp^.tsym^.lid; X dp^.tsym^.lid := ip; X np^.tsym := dp^.tsym; X dp^.tsym := sp; X np^.tsym^.lsymdecl := np; X dp^.tsym^.lsymdecl := dp; X (* make declaration global *) X moveglob(tp, ep); X (* add save/restore-code *) X addcode(tp, stackop(vp, np, dp)) X end; X goto 555 X end X end;(* case *) X while dp <> nil do X begin X if dp^.tsym^.lused then X begin X (* create a varpar declaration, X (nvarpar will cause emit to X treat the new identifier X as a pointer) *) X ep := mknode(nvarpar); X ep^.tattr := areference; X np := newid(mkrename('G', X dp^.tsym^.lid)); X ep^.tidl := np; X np^.tup := ep; X ep^.tbind := vp^.tbind; X if ep^.tbind^.tt = nid then X ep^.tbind^.tsym^.lused X := true; X (* swap id's and symbols *) X sp := np^.tsym; X ip := sp^.lid; X np^.tsym^.lid := dp^.tsym^.lid; X dp^.tsym^.lid := ip; X np^.tsym := dp^.tsym; X dp^.tsym := sp; X np^.tsym^.lsymdecl := np; X dp^.tsym^.lsymdecl := dp; X (* note that dp is referenced *) X dp^.tup^.tattr := aextern; X (* make declaration global *) X moveglob(tp, ep); X (* add save/restore-code *) X addcode(tp, stackop(vp, np, dp)) X end; X dp := dp^.tnext X end; X 555: X vp := vp^.tnext X end X end; (* movevars *) X X (* Break out a local variable and set the register *) X (* attribute. *) X procedure registervar(tp : treeptr); X X var vp, xp : treeptr; X X begin X vp := idup(tp); X tp := tp^.tsym^.lsymdecl; X (* vp points to nvar node *) X if (vp^.tidl <> tp) or (tp^.tnext <> nil) then X begin X (* tp is not alone in list of identifiers, X create a new nvar-node and hook up tp *) X xp := mknode(nvar); X xp^.tattr := anone; X xp^.tidl := tp; X tp^.tup := xp; X (* enter new nvar node among declarations *) X xp^.tup := vp^.tup; X xp^.tbind := vp^.tbind; (* borrow type *) X xp^.tnext := vp^.tnext; X vp^.tnext := xp; X (* break tp out of list of identifiers *) X if vp^.tidl = tp then X vp^.tidl := tp^.tnext X else begin X vp := vp^.tidl; X while vp^.tnext <> tp do X vp := vp^.tnext; X vp^.tnext := tp^.tnext X end; X tp^.tnext := nil X end; X (* tp is alone in this declaration, set attribute *) X if tp^.tup^.tattr = anone then X tp^.tup^.tattr := aregister X end; (* registervar *) X X (* Check static declarationlevel for a label *) X (* used in a non-local goto. *) X procedure cklevel(tp : treeptr); X X begin X tp := tp^.tsym^.lsymdecl; X while not(tp^.tt in [npgm, nproc, nfunc]) do X tp := tp^.tup; X if tp^.tstat > maxlevel then X maxlevel := tp^.tstat X end; X X begin (* global *) X while tp <> nil do X begin X case tp^.tt of X nproc, X nfunc: X begin X (* procid/parameters/const/type/var not used *) X markdecl(tp^.tsubid); X markdecl(tp^.tsubpar); X markdecl(tp^.tsubconst); X markdecl(tp^.tsubtype); X markdecl(tp^.tsubvar); X X (* mark those used in nested subroutines *) X global(tp^.tsubsub, tp, false); X X (* move out variables used in inner scope *) X movevars(tp, tp^.tsubpar); X movevars(tp, tp^.tsubvar); X (* move out const/type used in inner scope *) X tp^.tsubtype := movedecl(tp^.tsubtype); X tp^.tsubconst := movedecl(tp^.tsubconst); X X (* mark identifiers used in this subroutine *) X global(tp^.tsubstmt, tp, true); X global(tp^.tsubpar, tp, false); X global(tp^.tsubvar, tp, false); X global(tp^.tsubtype, tp, false); X global(tp^.tfuntyp, tp, false); X end; X X npgm: X begin X markdecl(tp^.tsubconst); X markdecl(tp^.tsubtype); X markdecl(tp^.tsubvar); X global(tp^.tsubsub, tp, false); X global(tp^.tsubstmt, tp, true) X end; X X nconst, X ntype, X nvar, X nfield, X nvalpar, X nvarpar: X begin X ip := tp^.tidl; X dep := depend; X while (ip <> nil) and not dep do X begin X (* for all used identifiers, propagate X the use to their bindings *) X if ip^.tsym^.lused then X dep := true; X ip := ip^.tnext X end; X global(tp^.tbind, dp, dep); X end; X nparproc, X nparfunc: X begin X global(tp^.tparparm, dp, depend); X global(tp^.tpartyp, dp, depend) X end; X nsubrange: X begin X global(tp^.tlo, dp, depend); X global(tp^.thi, dp, depend) X end; X nvariant: X begin X global(tp^.tselct, dp, depend); X global(tp^.tvrnt, dp, depend) X end; X nrecord: X begin X global(tp^.tflist, dp, depend); X global(tp^.tvlist, dp, depend) X end; X nconfarr: X begin X global(tp^.tcindx, dp, depend); X global(tp^.tcelem, dp, depend) X end; X narray: X begin X global(tp^.taindx, dp, depend); X global(tp^.taelem, dp, depend) X end; X nfileof, X nsetof: X global(tp^.tof, dp, depend); X nptr: X global(tp^.tptrid, dp, depend); X nscalar: X global(tp^.tscalid, dp, depend); X nbegin: X global(tp^.tbegin, dp, depend); X nif: X begin X global(tp^.tifxp, dp, depend); X global(tp^.tthen, dp, depend); X global(tp^.telse, dp, depend) X end; X nwhile: X begin X global(tp^.twhixp, dp, depend); X global(tp^.twhistmt, dp, depend) X end; X nrepeat: X begin X global(tp^.treptstmt, dp, depend); X global(tp^.treptxp, dp, depend) X end; X nfor: X begin X ip := idup(tp^.tforid); X if ip^.tup^.tt in [nproc, nfunc] then X registervar(tp^.tforid); X global(tp^.tforid, dp, depend); X global(tp^.tfrom, dp, depend); X global(tp^.tto, dp, depend); X global(tp^.tforstmt, dp, depend) X end; X ncase: X begin X global(tp^.tcasxp, dp, depend); X global(tp^.tcaslst, dp, depend); X global(tp^.tcasother, dp, depend) X end; X nchoise: X begin X global(tp^.tchocon, dp, depend); X global(tp^.tchostmt, dp, depend); X end; X nwith: X begin X global(tp^.twithvar, dp, depend); X global(tp^.twithstmt, dp, depend) X end; X nwithvar: X begin X ip := typeof(tp^.texpw); X if ip^.tuid = nil then X ip^.tuid := mkvariable('S'); X global(tp^.texpw, dp, depend); X end; X nlabstmt: X global(tp^.tstmt, dp, depend); X neq, nne, nlt, nle, ngt, nge: X begin X global(tp^.texpl, dp, depend); X global(tp^.texpr, dp, depend); X ip := typeof(tp^.texpl); X if (ip = typnods[tstring]) or X (ip^.tt = narray) then X usecomp := true; X ip := typeof(tp^.texpr); X if (ip = typnods[tstring]) or X (ip^.tt = narray) then X usecomp := true X end; X nin, nor, nplus, nminus, X nand, nmul, ndiv, nmod, nquot, X nformat, nrange: X begin X global(tp^.texpl, dp, depend); X global(tp^.texpr, dp, depend) X end; X X nassign: X begin X global(tp^.tlhs, dp, depend); X global(tp^.trhs, dp, depend) X end; X X nnot, X numinus, X nuplus, X nderef: X global(tp^.texps, dp, depend); X nset: X global(tp^.texps, dp, depend); X nindex: X begin X global(tp^.tvariable, dp, depend); X global(tp^.toffset, dp, depend) X end; X nselect: X global(tp^.trecord, dp, depend); X ncall: X begin X global(tp^.tcall, dp, depend); X global(tp^.taparm, dp, depend) X end; X nid: X begin X (* find declaration point *) X ip := idup(tp); X if ip = nil then X goto 555; X (* ip points to nconst/ntype/nvar/nproc/nfunc/ X nvalpar/nvarpar/nparproc or nparfunc node, X move to beginning of enclosing scope *) X repeat X ip := ip^.tup; X if ip = nil then X goto 555 X (* stop only for locally declared items, X for global or predefined identifiers X we will have gone to label 555 *) X until ip^.tt in [npgm, nproc, nfunc]; X if dp = ip then X begin X (* identifier used here, mark it used *) X if depend then X tp^.tsym^.lused := true X end X else begin X (* identifier declared in enclosing X scope, mark it used *) X tp^.tsym^.lused := true X end; X 555: X end; X ngoto: X if not islocal(tp^.tlabel) then X begin X tp^.tlabel^.tsym^.lgo := true; X usejmps := true; X cklevel(tp^.tlabel) X end; X X nbreak, X npush, X npop, X npredef, X nempty, X nchar, X ninteger, X nreal, X nstring, X nnil: X end;(* case *) X tp := tp^.tnext X end X end; (* global *) X X (* Rename identifiers identical to C keywords. *) X procedure renamc; X X var ip : idptr; X cn : cnames; X X begin X (* rename identifiers that mustn't be redefined X if C and Pascal semantix are to be preserved *) X for cn := cabort to cwrite do X begin X ip := mkrename('C', ctable[cn]); X ctable[cn]^.istr := ip^.istr X end X end; X X (* Rename subroutines declared in other subroutines such *) X (* that they can be moved to a global scope without name- *) X (* clashes. *) X procedure renamp(tp : treeptr; on : boolean); X X var sp : symptr; X X begin X (* tp points to subroutine-list *) X while tp <> nil do X begin X renamp(tp^.tsubsub, true); X if on and (tp^.tsubstmt <> nil) then X begin X (* change name of subroutine by prefixing X a unique name *) X sp := tp^.tsubid^.tsym; X if sp^.lid^.inref > 1 then X begin X sp^.lid := mkrename('P', sp^.lid); X sp^.lid^.inref := sp^.lid^.inref - 1 X end X end; X tp := tp^.tnext X end X end; X X (* Add initialization-code for file-variables. *) X procedure initcode(tp : treeptr); X X var ti, tq, tu, tv : treeptr; X X (* Determine if a type contains a file. *) X function filevar(tp : treeptr) : boolean; X X var fv : boolean; X tq : treeptr; X X begin X case tp^.tt of X npredef: X fv := tp = typnods[ttext]; X nfileof: X fv := true; X nconfarr: X fv := filevar(typeof(tp^.tcelem)); X narray: X fv := filevar(typeof(tp^.taelem)); X nrecord: X begin X fv := false; X tq := tp^.tvlist; X while tq <> nil do X begin X if filevar(tq^.tvrnt) then X error(evrntfile); X tq := tq^.tnext X end; X tq := tp^.tflist; X while tq <> nil do X begin X if filevar(typeof(tq^.tbind)) then X begin X fv := true; X tq := nil X end X else X tq := tq^.tnext X end X end; X nptr: X begin X fv := false; X if not tp^.tptrflag then X begin X tp^.tptrflag := true; X if filevar(typeof(tp^.tptrid)) then X error(evarfile); X tp^.tptrflag := false X end X end; X nsubrange, X nscalar, X nsetof: X fv := false X end; X filevar := fv X end; X X (* Create code for initialization of files. *) X function fileinit(ti, tq : treeptr; opn : boolean) : treeptr; X X var tx, ty, tz : treeptr; X X begin X (* create 1 statement initializing "ti" *) X case tq^.tt of X narray: X begin X (* create declaration for a loopvariable *) X tz := newid(mkvariable('I')); X ty := mknode(nvar); X ty^.tattr := aregister; X ty^.tidl := tz; X ty^.tbind := typeof(tq^.taindx); X tz := tq; X while not(tz^.tt in [nproc, nfunc, npgm]) do X tz := tz^.tup; X linkup(tz, ty); X if tz^.tsubvar = nil then X tz^.tsubvar := ty X else begin X tz := tz^.tsubvar; X while tz^.tnext <> nil do X tz := tz^.tnext; X tz^.tnext := ty X end; X ty := ty^.tidl; X (* create a loop initializing tq *) X tz := mknode(nindex); X tz^.tvariable := ti; X tz^.toffset := ty; X tz := fileinit(tz, tq^.taelem, opn); X tx := mknode(nfor); X tx^.tforid := ty; X ty := typeof(tq^.taindx); X if ty^.tt = nsubrange then X begin X tx^.tfrom := ty^.tlo; X END_OF_FILE if test 52771 -ne `wc -c <'ptc.p.2'`; then echo shar: \"'ptc.p.2'\" unpacked with wrong size! fi # end of 'ptc.p.2' fi echo shar: End of archive 10 $of 12$. cp /dev/null ark10isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 12 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0 -- Rich $alz "Anger is an energy" Cronus Project, BBN Labs rsalz@bbn.com Moderator, comp.sources.unix sources@uunet.uu.net